# Alterando Padrao em PTBR
Sys.setlocale("LC_ALL", "pt_br.utf-8")
## [1] "pt_br.utf-8/pt_br.utf-8/pt_br.utf-8/C/pt_br.utf-8/en_US.UTF-8"
# Data Frame com a segmentacao da analise
segmentacao = data.frame(matrix(ncol = 2, nrow = 0))
segcol = c("tipo", "valor")
colnames(segmentacao) = segcol
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
# Pacotes utilizados para o trabalho
pacotes = c('sqldf', 'ggplot2', 'dplyr', 'knitr', 'geosphere', 'lubridate', 'e1071', 'caret', 'randomForest', 'ggmap', 'lattice', 'leaflet', 'plotly', 'seewave')
carregaLibs = function (lista){
# Percorre a lista para verificar se o pacote está instalado.
for (x in lista){
# A Negacao do require instala o pacote
if (!require(x, character.only = TRUE)){
install.packages(x, dependencies = TRUE)
# Aplica o iteravel no require, para carregar a Lib no R
sapply(x, library, character.only = TRUE)
}
}
}
set.seed(10)
# Carrega Pacotes
carregaLibs(pacotes)
Primeiro vamos carregar o dataset e em seguida ver informações estatísticas sobre a base.
# Load do dataset
data = read.csv("./train.csv")
segmentacao = rbind(segmentacao, data.frame("tipo" = "Load Dataset", "valor" = 1))
dim(data)
## [1] 1458644 11
# Analise da Base
kable(summary(data[,-1], 5))
| vendor_id | pickup_datetime | dropoff_datetime | passenger_count | pickup_longitude | pickup_latitude | dropoff_longitude | dropoff_latitude | store_and_fwd_flag | trip_duration | |
|---|---|---|---|---|---|---|---|---|---|---|
| Min. :1.000 | 2016-01-12 18:48:44: 5 | 2016-02-19 19:25:04: 5 | Min. :0.000 | Min. :-121.93 | Min. :34.36 | Min. :-121.93 | Min. :32.18 | N:1450599 | Min. : 1 | |
| 1st Qu.:1.000 | 2016-02-09 21:03:38: 5 | 2016-05-16 19:40:28: 5 | 1st Qu.:1.000 | 1st Qu.: -73.99 | 1st Qu.:40.74 | 1st Qu.: -73.99 | 1st Qu.:40.74 | Y: 8045 | 1st Qu.: 397 | |
| Median :2.000 | 2016-03-04 08:07:34: 5 | 2016-01-07 08:04:32: 4 | Median :1.000 | Median : -73.98 | Median :40.75 | Median : -73.98 | Median :40.75 | NA | Median : 662 | |
| Mean :1.535 | 2016-04-05 18:55:21: 5 | 2016-01-08 12:43:38: 4 | Mean :1.665 | Mean : -73.97 | Mean :40.75 | Mean : -73.97 | Mean :40.75 | NA | Mean : 959 | |
| 3rd Qu.:2.000 | (Other) :1458624 | (Other) :1458626 | 3rd Qu.:2.000 | 3rd Qu.: -73.97 | 3rd Qu.:40.77 | 3rd Qu.: -73.96 | 3rd Qu.:40.77 | NA | 3rd Qu.: 1075 | |
| Max. :2.000 | NA | NA | Max. :9.000 | Max. : -61.34 | Max. :51.88 | Max. : -61.34 | Max. :43.92 | NA | Max. :3526282 |
Os dados existentes na base são:
Para a análise é interessante gerar novos dados baseados nos dados já exisitentes. Dessa forma é possível identificar mais informações sobre o nosso dataset.
Distância Euclidiana:
# Calculo distancia euclidiana, menor distancia em metros entre ponto A e ponto B, linha reta.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
data$euclidiana = round(distHaversine(cbind(data$pickup_longitude, data$pickup_latitude),
cbind(data$dropoff_longitude, data$dropoff_latitude)), digits = 2)
Distância de Manhattan:
# Calculo distancia manhattan, em metros, entre ponto A e ponto B, quadrado, tambem conhecido como City Blocks.
# Funcao de calculo
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
manhattan_calc = function (pickup_lat,
pickup_long,
dropoff_lat,
dropoff_long){
lat_dist = distHaversine(cbind(pickup_long, pickup_lat),
cbind(dropoff_long, pickup_lat))
long_dist = distHaversine(cbind(pickup_long, pickup_lat),
cbind(pickup_long, dropoff_lat))
return (abs(lat_dist) + abs(long_dist))
}
# adicionando no dataset
data$manhattan = round(manhattan_calc(data$pickup_latitude, data$pickup_longitude,
data$dropoff_latitude, data$dropoff_longitude), digits = 2)
Podemos gerar quadrantes e identificar onde cada corrida iniciou, e finalizou, de acordo com essa informação. Os quadrantes possuem no máximo 20 metros quadrados. Para isso, serão feitos os seguintes passos:
# Discretizando os pontos em quadrantes
# sqldf permite a utilização de queries para leitura do dataframe.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Analise Geografica", "valor" = 1))
# Delimitando os dados
# Minima latitude
data <- subset(data, data$pickup_latitude > 40.624097)
data <- subset(data, data$dropoff_latitude > 40.624097)
# Maxima latitude
data <- subset(data, data$pickup_latitude < 40.845439)
data <- subset(data, data$dropoff_latitude < 40.845439)
# Minima longitude
data <- subset(data, data$pickup_longitude > -74.013963)
data <- subset(data, data$dropoff_longitude > -74.013963)
# Maxima longitude
data <- subset(data, data$pickup_longitude< -73.735253)
data <- subset(data, data$dropoff_longitude < -73.735253)
# Ordenando o Dataset pelo ID
data <- data[order(data$id),]
# Parametros para criar os quadrantes
# Pontos extremos (latitude, longitude) detro da area delimitada e tamanho do intervalo dos quadrantes
quadrante <- list (latitude.min = (min(min(data$pickup_latitude),min(data$dropoff_latitude))),
latitude.max = (max(max(data$pickup_latitude),max(data$dropoff_latitude)))+0.02,
latitude.intervalo = 0.02,
longitude.min = (min(min(data$pickup_longitude),min(data$dropoff_longitude))),
longitude.max = (max(max(data$pickup_longitude),max(data$dropoff_longitude)))+0.02,
longitude.intervalo = 0.02)
# Determinando os limites de cada quadrante na latitude e na longitude
quadrante$latitude.limite = seq (from = quadrante$latitude.min,
to = quadrante$latitude.max,
by = quadrante$latitude.intervalo)
quadrante$longitude.limite = seq (from = quadrante$longitude.min,
to = quadrante$longitude.max,
by = quadrante$longitude.intervalo)
# Verificando a quantidade de quadrantes na latitude, longitude e no total
quadrante$latitude.quantidade = length(quadrante$latitude.limite)
quadrante$longitude.quantidade = length(quadrante$longitude.limite)
quadrante$quantidade.total = quadrante$latitude.quantidade * quadrante$longitude.quantidade
# Atribuindo nomes aos quadrantes
quadrante$X <- paste0('X', seq_len(quadrante$latitude.quantidade))
quadrante$Y <- paste0('Y', seq_len(quadrante$longitude.quantidade))
quadrante$total <- paste0('Q', seq_len(quadrante$quantidade.total))
# Criando um dataframe com os atributos dos quadrantes
# Nome do Quadrante / Seq em X / Seq em Y / X inicio / X fim / y inicio / Y fim / X centro / Y centro dos quadrantes
atributos_quadrantes <- data.frame(names=quadrante$total, row.names=quadrante$total)
atributos_quadrantes <- mutate(atributos_quadrantes,
x = rep(quadrante$X, each=quadrante$longitude.quantidade),
y = rep(quadrante$Y, quadrante$latitude.quantidade),
x_inicio = rep(quadrante$latitude.limite[1: quadrante$latitude.quantidade], each=quadrante$longitude.quantidade),
x_fim = rep(quadrante$latitude.limite[2:(quadrante$latitude.quantidade +1)], each=quadrante$longitude.quantidade),
y_inicio = rep(quadrante$longitude.limite[1:quadrante$longitude.quantidade], quadrante$latitude.quantidade),
y_fim = rep(quadrante$longitude.limite[2:(quadrante$longitude.quantidade +1)], quadrante$latitude.quantidade),
x_centro = (x_fim - x_inicio)/2.0 + x_inicio,
y_centro = (y_fim - y_inicio)/2.0 + y_inicio
)
# Quadrantes por Corrida
# Encontrando a qual quadrante pertence cada ponto de Pickup dos dados de corridas de taxi ordenados por id
relacao_data_quadrantes_pickup = sqldf (" select data.id,
atributos_quadrantes.names,
atributos_quadrantes.x,
atributos_quadrantes.y
from atributos_quadrantes
inner join data
where atributos_quadrantes.x_inicio <= data.pickup_latitude
and x_fim > data.pickup_latitude
and atributos_quadrantes.y_inicio <= data.pickup_longitude
and y_fim > data.pickup_longitude
order by data.id")
# Encontrando a qual quadrante pertence cada ponto de Dropoff dos dados de corridas de taxi ordenados por id
relacao_data_quadrantes_dropoff = sqldf (" select data.id,
atributos_quadrantes.names,
atributos_quadrantes.x,
atributos_quadrantes.y
from atributos_quadrantes
inner join data
where atributos_quadrantes.x_inicio <= data.dropoff_latitude
and x_fim > data.dropoff_latitude
and atributos_quadrantes.y_inicio <= data.dropoff_longitude
and y_fim > data.dropoff_longitude
order by data.id")
# Inserindo no dataframe de corridas o dado do nome do quadrante de Pickup e de Dropoff
data <- mutate(data,
pickup_quadrante = relacao_data_quadrantes_pickup$names,
pickup_quadrante_x = relacao_data_quadrantes_pickup$x,
pickup_quadrante_y = relacao_data_quadrantes_pickup$y,
dropoff_quadrante = relacao_data_quadrantes_dropoff$names,
dropoff_quadrante_x = relacao_data_quadrantes_dropoff$x,
dropoff_quadrante_y = relacao_data_quadrantes_dropoff$y)
Exemplo de como os dados ficaram após a geração dos quadrantes:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
kable(head(select(data, id, pickup_datetime, dropoff_datetime, trip_duration, pickup_quadrante, dropoff_quadrante)))
| id | pickup_datetime | dropoff_datetime | trip_duration | pickup_quadrante | dropoff_quadrante |
|---|---|---|---|---|---|
| id0000001 | 2016-06-14 10:43:10 | 2016-06-14 11:01:35 | 1105 | Q61 | Q93 |
| id0000003 | 2016-03-16 10:39:55 | 2016-03-16 10:57:21 | 1046 | Q92 | Q76 |
| id0000005 | 2016-04-25 09:50:48 | 2016-04-25 09:56:56 | 368 | Q124 | Q123 |
| id0000009 | 2016-05-08 01:43:11 | 2016-05-08 01:52:18 | 547 | Q92 | Q123 |
| id0000011 | 2016-03-04 22:20:52 | 2016-03-04 22:25:08 | 256 | Q108 | Q92 |
| id0000013 | 2016-02-19 13:58:59 | 2016-02-19 14:06:06 | 427 | Q93 | Q92 |
Velocidade é outro campo não existente no dataset. Para o cálculo usaremos a distancia de Manhattan, que determina de uma forma mais precisa a distancia real entre os pontos e o tempo em segundos da viagem, que está no campo trip_duration. Para gerar a velocidade média vamos utilizar a formula: Vm = Distancia(em KM)/Tempo(em Horas).
# Tempo de viagem está em segundos, vamos converter para horas.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
data$velocidade_media = (data$manhattan/1000)/(data$trip_duration/3600)
As informações de data também não são tão completas. Podemos quebrar os dados de pickup e dropoff e ter mais informações, como dia da semana, hora do dia, minuto do dia, entre outros.
# Quebrando informações de tempo.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
# Pickup
data = mutate(data,
dia_semana_pickup = weekdays(as.Date(pickup_datetime)),
data_pickup = format(as.POSIXct(pickup_datetime),format = "%d/%m/%y"),
hora_pickup = format(as.POSIXct(pickup_datetime) ,format = "%H"),
minutos_pickup = format(as.POSIXct(pickup_datetime) ,format = "%M"),
mes_pickup = months(as.Date(pickup_datetime)),
numero_dia_pickup = case_when(dia_semana_pickup == 'Sunday' | dia_semana_pickup == 'Domingo' ~ 1,
dia_semana_pickup == 'Monday' | dia_semana_pickup == 'Segunda Feira' ~ 2,
dia_semana_pickup == 'Tuesday' | dia_semana_pickup == 'Terça Feira' ~ 3,
dia_semana_pickup == 'Wednesday' | dia_semana_pickup == 'Quarta Feira' ~ 4,
dia_semana_pickup == 'Thursday' | dia_semana_pickup == 'Quinta Feira' ~ 5,
dia_semana_pickup == 'Friday' | dia_semana_pickup == 'Sexta Feira' ~ 6,
dia_semana_pickup == 'Saturday' | dia_semana_pickup == 'Sábado' ~ 7),
numero_mes_pickup = case_when(mes_pickup == 'January' | mes_pickup == 'Janeiro' ~ 1,
mes_pickup == 'February' | mes_pickup == 'Fevereiro' ~ 2,
mes_pickup == 'March' | mes_pickup == 'Março' ~ 3,
mes_pickup == 'April' | mes_pickup == 'Abril' ~ 4,
mes_pickup == 'May' | mes_pickup == 'Maio' ~ 5,
mes_pickup == 'June' | mes_pickup == 'Junho' ~ 6,
mes_pickup == 'July' | mes_pickup == 'Julho' ~ 7,
mes_pickup == 'August' | mes_pickup == 'Agosto' ~ 8,
mes_pickup == 'September' | mes_pickup == 'Setembro' ~ 9,
mes_pickup == 'October' | mes_pickup == 'Outubro' ~ 10,
mes_pickup == 'November' | mes_pickup == 'Novembro' ~ 11,
mes_pickup == 'December' | mes_pickup == 'Dezembro' ~ 12))
# Dropoff
data = mutate(data,
dia_semana_dropoff = weekdays(as.Date(dropoff_datetime)),
data_dropoff = format(as.POSIXct(dropoff_datetime),format = "%d/%m/%y"),
hora_dropoff = format(as.POSIXct(dropoff_datetime) ,format = "%H"),
minutos_dropoff = format(as.POSIXct(dropoff_datetime) ,format = "%M"),
mes_dropoff = months(as.Date(dropoff_datetime)),
numero_dia_dropoff = case_when(dia_semana_dropoff == 'Sunday' | dia_semana_dropoff == 'Domingo' ~ 1,
dia_semana_dropoff == 'Monday' | dia_semana_dropoff == 'Segunda Feira' ~ 2,
dia_semana_dropoff == 'Tuesday' | dia_semana_dropoff == 'Terça Feira' ~ 3,
dia_semana_dropoff == 'Wednesday' | dia_semana_dropoff == 'Quarta Feira' ~ 4,
dia_semana_dropoff == 'Thursday' | dia_semana_dropoff == 'Quinta Feira' ~ 5,
dia_semana_dropoff == 'Friday' | dia_semana_dropoff == 'Sexta Feira' ~ 6,
dia_semana_dropoff == 'Saturday' | dia_semana_dropoff == 'Sábado' ~ 7),
numero_mes_dropoff = case_when(mes_dropoff == 'January' | mes_dropoff == 'Janeiro' ~ 1,
mes_dropoff == 'February' | mes_dropoff == 'Fevereiro' ~ 2,
mes_dropoff == 'March' | mes_dropoff == 'Março' ~ 3,
mes_dropoff == 'April' | mes_dropoff == 'Abril' ~ 4,
mes_dropoff == 'May' | mes_dropoff == 'Maio' ~ 5,
mes_dropoff == 'June' | mes_dropoff == 'Junho' ~ 6,
mes_dropoff == 'July' | mes_dropoff == 'Julho' ~ 7,
mes_dropoff == 'August' | mes_dropoff == 'Agosto' ~ 8,
mes_dropoff == 'September' | mes_dropoff == 'Setembro' ~ 9,
mes_dropoff == 'October' | mes_dropoff == 'Outubro' ~ 10,
mes_dropoff == 'November' | mes_dropoff == 'Novembro' ~ 11,
mes_dropoff == 'December' | mes_dropoff == 'Dezembro' ~ 12))
Exemplo de como alguns dados ficaram após a quebra das datas:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
kable(head(select(data, dia_semana_pickup, numero_dia_pickup, mes_pickup, numero_mes_pickup)))
| dia_semana_pickup | numero_dia_pickup | mes_pickup | numero_mes_pickup |
|---|---|---|---|
| Terça Feira | 3 | Junho | 6 |
| Quarta Feira | 4 | Março | 3 |
| Segunda Feira | 2 | Abril | 4 |
| Domingo | 1 | Maio | 5 |
| Sexta Feira | 6 | Março | 3 |
| Sexta Feira | 6 | Fevereiro | 2 |
Uma vez com os dados separados por quadrantes também é interessante identificar pontos de interesse, como Aeroportos, pontos turisticos, etc. Os pontos utilizados nesta análise foram:
As informações desses pontos de intesse foram adicionados ao arquivo externo ‘pontos_interesse.csv’. Esses dados foram coletados através de geolocalização providos pelo Google Maps.
# Lendo dados de latitude e longitude dos pontos de interesse
segmentacao = rbind(segmentacao, data.frame("tipo" = "Load Dataset", "valor" = 1))
pontos_interesse = read.csv("pontos_interesse.csv")
# Encontrando a qualquadrante cada ponto de interesse pertence
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Preparacao de Dados", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Analise Geografica", "valor" = 1))
relacao_quadr_ponto_interesse = sqldf ("select pontos_interesse.id,
atributos_quadrantes.names,
atributos_quadrantes.x,
atributos_quadrantes.y
from atributos_quadrantes
inner join pontos_interesse
where atributos_quadrantes.x_inicio <= pontos_interesse.latitude
and x_fim > pontos_interesse.latitude
and atributos_quadrantes.y_inicio <= pontos_interesse.longitude
and y_fim > pontos_interesse.longitude
order by pontos_interesse.id")
# Inserindo no dataframe de pontos de interesse os dados dos quadrantes
pontos_interesse <- mutate(pontos_interesse,
quadrante = relacao_quadr_ponto_interesse$names,
quadrante_x = relacao_quadr_ponto_interesse$x,
quadrante_y = relacao_quadr_ponto_interesse$y)
# Todos os quadrantes ordenados pela quantidade de Pickup e Dropoff
ord_quadrantes_pickup = sqldf ("select data.pickup_quadrante,
count(1) as quantidade
from data
group by data.pickup_quadrante
order by 2 desc")
ord_quadrantes_dropoff = sqldf ("select data.dropoff_quadrante,
count(1) as quantidade
from data
group by data.dropoff_quadrante
order by 2 desc")
# Quadrantes dos pontos de interesse ordenados pela quantidade de Pickup e Dropoff
ord_pontos_interesse_pickup = sqldf ("select ord_quadrantes_pickup.pickup_quadrante,
ord_quadrantes_pickup.quantidade,
pontos_interesse.lugar,
pontos_interesse.categoria
from ord_quadrantes_pickup
left join pontos_interesse
on ord_quadrantes_pickup.pickup_quadrante = pontos_interesse.quadrante
order by 2 desc")
ord_pontos_interesse_dropoff = sqldf ("select ord_quadrantes_dropoff.dropoff_quadrante,
ord_quadrantes_dropoff.quantidade,
pontos_interesse.lugar,
pontos_interesse.categoria
from ord_quadrantes_dropoff
inner join pontos_interesse
on ord_quadrantes_dropoff.dropoff_quadrante = pontos_interesse.quadrante
order by 2 desc")
Os pontos de interesse são dividos em categorias e o gráfico abaixo mostra a proporção deles:
# Pontos de Interesses
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
contagem = pontos_interesse %>%
group_by(categoria) %>%
summarise(count=n())
plot_ly(pontos_interesse, labels = ~categoria, values = contagem, type = 'pie') %>%
layout(title = 'Pontos de interesse por categoria',
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
Com essas informações é possível realizar um cruzamento dos pontos de interesse e as corridas. Dessa forma podemos identificar a quantidade de corridas por pelo menos um dos pontos de interesse identificados.
Quantidade de corridas por categoria de ponto de interesse:
# Corridas por Ponto de Interesse
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
pickup_cpi = ord_pontos_interesse_pickup %>%
group_by(categoria) %>%
summarise(total=sum(quantidade))
# Tratamento de Nulos
pickup_cpi$categoria[is.na(pickup_cpi$categoria)] = "Ponto de Interesse sem Corridas no Quadrante"
plot_ly(pickup_cpi, labels = ~categoria, values = ~total, type = 'pie') %>%
layout(title = 'Quantidade de Viagens por Categoria de Interesse',
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
Temos um total de 8 categorias de pontos de interesse. Aproximadamente 23% das corridas vão para Hospitais, enquanto é seguido por 17% de ambientes Culturais e 15% em Hoteis e Restaurantes.
Neste momento iremos explorar nossos dados, compreende-los melhor e ter um resumo sobre o que os mesmos podem nos dizer.
Qual a quantidade de corridas por mês?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
plotFonte = list(family = "Dubai, monospace", size = 18, color = "#7f7f7f")
# Corridas por mes
corridaMes <- data %>%
group_by(mes_pickup,
numero_mes_pickup) %>%
summarise(count=n())
colnames(corridaMes) = c('mes','nrmes','corrida')
corridaMes <- corridaMes[order(corridaMes$nrmes),]
xlabel = list(title = "Mês de Referencia", titlefont = plotFonte)
ylabel = list(title = "Quantidade de Corridas", titlefont = plotFonte)
plot_ly(x = corridaMes$nrmes, y = corridaMes$corrida, name = corridaMes$mes, type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
Qual a quantidade de corridas iniciadas pelo dia da semana?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Corridas iniciadas por dia
corridaDia <- data %>%
group_by(dia_semana_pickup,
numero_dia_pickup) %>%
summarise(count=n())
colnames(corridaDia) = c('dia','nrdia','corridas')
corridaDia <- corridaDia[order(corridaDia$nrdia),]
xlabel = list(title = "Dia da Semana", titlefont = plotFonte)
ylabel = list(title = "Quantidade de Corridas", titlefont = plotFonte)
plot_ly(x = corridaDia$nrdia, y = corridaDia$corridas, name = corridaDia$dia, type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
E a quantidade de corridas finalizadas pelo dia da semana?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Corridas finalizadas por dia
corridaDia <- data %>%
group_by(dia_semana_pickup,
numero_dia_pickup) %>%
summarise(count=n())
colnames(corridaDia) = c('dia','nrdia','corridas')
corridaDia <- corridaDia[order(corridaDia$nrdia),]
xlabel = list(title = "Dia da Semana", titlefont = plotFonte)
ylabel = list(title = "Quantidade de Corridas", titlefont = plotFonte)
plot_ly(x = corridaDia$nrdia, y = corridaDia$corridas, name = corridaDia$dia, type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
Que tal a quantidade de corridas por hora?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Corridas por hora
corridasHora = data %>%
group_by(hora_pickup) %>%
summarise(count=n())
corridasHora <- corridasHora[order(corridasHora$hora_pickup),]
xlabel = list(title = "Hora do dia", titlefont = plotFonte)
ylabel = list(title = "Quantidade de Corridas", titlefont = plotFonte)
plot_ly(x = corridasHora$hora_pickup, y = corridasHora$count, name = corridasHora$hora_pickup, type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
Qual o tempo médio da viagem em função do horário?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Tempo Medio por Hora
tempoHora = data %>%
group_by(hora_pickup) %>%
summarise_at(vars(trip_duration), funs(mean(., na.rm=TRUE)))
xlabel = list(title = "Hora do dia", titlefont = plotFonte)
ylabel = list(title = "Minutos", titlefont = plotFonte)
plot_ly(x = tempoHora$hora_pickup, y = (tempoHora$trip_duration/60), name = tempoHora$hora_pickup,type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
E a velocidade média em função do horário?
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Velocidade Média por Hora
velocidadeHora = data %>%
group_by(hora_pickup) %>%
summarise_at(vars(velocidade_media), funs(mean(., na.rm=TRUE)))
xlabel = list(title = "Hora do dia", titlefont = plotFonte)
ylabel = list(title = "Velocidade Média em KM/h", titlefont = plotFonte)
plot_ly(x = velocidadeHora$hora_pickup, y = (velocidadeHora$velocidade_media), name = velocidadeHora$hora_pickup,type = 'bar') %>%
layout(xaxis = xlabel, yaxis = ylabel)
Após as análises desse gráficos podem dizer que:
Para as futuras analises, o dataset será filtrado para 5000 observações.
Todas as analises daqui a frente serão feitas considerando o novo conjunto de dados.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
# Gerando subset
corridas.aleatorios <- sample(unique(data$id), 5000)
data = data %>%
subset(id %in% corridas.aleatorios)
Clusters são agrupamentos dos dados. Dessa forma podemos identificar relações escondidas dentro dos dados.
Abaixo temos um gráfico mostrando 4 grupos de dados em um plot 3D, onde temos a relação Velocidade Média por Distãncia em função do tempo.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
data3d <- data.frame(data$hora_pickup, data$velocidade_media, data$manhattan)
modelo3d <- kmeans(x = data3d, center = 6)
xlabel = list(title = "Horario da Corrida", titlefont = plotFonte)
ylabel = list(title = "Distancia Percorrida", titlefont = plotFonte)
zlabel = list(title = "Velocidade Media", titlefont = plotFonte)
data %>% mutate(cluster = modelo3d$cluster) %>%
plot_ly(data= . , x = ~hora_pickup, y = ~manhattan, z = ~velocidade_media,
text = ~data_pickup,
type = 'scatter3d',
mode = 'markers',
color= ~cluster,
size = rep(1, dim(data)[1]), sizes = c(3.0)) %>%
layout(
title = "Clusters das Corridas",
scene = list(
xaxis = xlabel,
yaxis = ylabel,
zaxis = zlabel)
)
Podemos ver que os Grupos são apresentados basicamente de acordo com a distãncia percorrida
Análise de mapas são importantes para uma melhor visualização dos dados. Utilizaremos o mapa do Brooklyn para centralização geográfica.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Analise Geografica", "valor" = 1))
#Criando o mapa com o foco no Brooklyn (assim o mapa ficou mais centralizado)
NY_center = as.numeric(geocode("Brooklyn"))
NYMap = ggmap(get_googlemap(center=NY_center,scale=2, zoom=11))
NYMap
Com os dados existentes podem ser gerados Mapas de Calor, que representam a quantidade de ocorrências em determinados cruzamentos de dados.
Nos casos de Taxi, podemos verificar quais são os principais pontos de partida dos taxis.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Analise Geografica", "valor" = 1))
# criando dataframe para os plots de todos os pickups
num_pickup = data.frame(data$pickup_longitude,data$pickup_latitude)
colnames(num_pickup)= c('longitude','latitutde')
# criando dataframe para os plots de todos os dropoffs
num_dropoff = data.frame(data$dropoff_longitude,data$dropoff_latitude)
colnames(num_dropoff)= c('longitude','latitutde')
# plot de calor dos pickup
NYMap + stat_density2d(aes(x = longitude, y = latitutde, fill = ..level.., alpha = 0.25),
size = 0.03,
bins = 50,
data = num_pickup,
geom = "polygon") + scale_fill_distiller(palette = 'RdYlGn')
Também podemos verificar os principáis pontos de finalização das partidas.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Analise Geografica", "valor" = 1))
# plot de calor dos dropoff
NYMap + stat_density2d(aes(x = longitude, y = latitutde, fill = ..level.., alpha = 0.25),
size = 0.01,
bins = 50,
data = num_dropoff,
geom = "polygon") + scale_fill_distiller(palette = 'RdYlGn')
Os mapas de calor nos mostram aonde existem as maiores concentrações de viagens no Mapa, onde, por exemplo, é possível identificar que existem uma concetração de viagens no Aeroporto John Kennedy e que as corridas iniciam e terminam bem no centro de Manhattan, basicamente em torno do Central Park.
A Geração de novas informações no dataset, como datas, distancias, etc, além de gerar novas informações úteis para análises também são importantes para a modelagem que será utilizada em modelos de Machine Learning. Neste momento iremos utilizar algumas variáveis que serão responsáveis para treinamento de um modelo de regressão.
O Modelo escolhido foi o RandomForest, e as variáveis serão:
Essas informações são importantes para, por exemplo, poder aprende a velocidade média, já que existem discrepancias na mesma região de acordo com os horários de pico, feriados, pontos turisticos, em dias diferentes, ou até mesmo em horários diferentes. Portanto, nossa regressão irá prever a velocidade média considerando como entrada todas as informações passadas acima.
# Funcao para normalizar
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Modelagem", "valor" = 1))
normalizacao <- function(x) {
return((x-min(x)) / (max(x)-min(x)))
}
# Normalizando
# Reduzindo dataset
predicao_velocidade = data %>%
select(numero_mes_pickup, numero_dia_pickup, hora_pickup, minutos_pickup, manhattan,
numero_mes_dropoff, numero_dia_dropoff, hora_dropoff, minutos_dropoff, trip_duration, velocidade_media) %>%
mutate(manhattan = normalizacao(manhattan),
numero_mes_pickup = normalizacao(numero_mes_pickup),
numero_dia_pickup = normalizacao(numero_dia_pickup),
hora_pickup = normalizacao(as.integer(hora_pickup)),
minutos_pickup = normalizacao(as.integer(minutos_pickup)),
numero_mes_dropoff = normalizacao(numero_mes_dropoff),
numero_dia_dropoff = normalizacao(numero_dia_dropoff),
hora_dropoff = normalizacao(as.integer(hora_dropoff)),
minutos_dropoff = normalizacao(as.integer(minutos_dropoff)),
trip_duration = normalizacao(trip_duration),
velocidade_media = velocidade_media)
Existem corridas que possuem horário de inicio, ou de fim, as 00 e outras as 23. Como estamos trabalhando com modelos matematicos e a grandeza dos números é dispersa iremos normalizar todas as informações que serão utilizadas no modelo, entre 0 e 1. Dessa forma estamos padronizando os dados e ajudando na eficiencia do modelo matemático para gerar nossa função de regressão.
A Separação do dataset se faz necessária para aprendizado do modelo matemático, que será feita em 2 partes: Conjunto de Treino e Conjunto de Teste.
# Separando datasets
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
indice = sample(2, nrow(predicao_velocidade), replace=TRUE, prob=c(0.7, 0.3))
# Treino
predicao_velocidade_treino = predicao_velocidade[indice==1,]
# Teste
predicao_velocidade_teste = predicao_velocidade[indice==2,]
Com nossos dados de entrada, vamos analisas as correlações entre as variávels:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Analise de Correlacoes
# Matriz com valores absolutos das correlacoes
matriz_modelagem = abs(cor(predicao_velocidade))
# Matriz diagonal recebe 0
diag(matriz_modelagem) = 0
# Retorna onde os indices sao TRUE, onde a matriz possui indice maior que 0.8
which(matriz_modelagem > 0.8, arr.ind = T)
## row col
## numero_mes_dropoff 6 1
## numero_dia_dropoff 7 2
## hora_dropoff 8 3
## numero_mes_pickup 1 6
## numero_dia_pickup 2 7
## hora_pickup 3 8
Apesar do modelo apresentar correlações entre os dados de mês, dia, hora de pickup e dropoff , não iremos utilizar outras técnicas de redução de dimensionalidade. Estes dados são independentes, e apesar de bem relacionados, já que existem muitas corridas que iniciam e terminam no mesmo dia, remover estes campos iria remover a interpretação do modelo para casos de corridas que viram a meia noite, já que são dias diferentes. Considerando que horários de pico e alguns dias específicos podem ser determinantes para a velocidade, iremos manter as informações como estão.
O Modelo RandomForest será utilizado, porém, vamos analisar quantas árvores são necessárias para esse modelo. O Teste será feito com 500 árvores, e com o resultado no gráfico iremos decidir qual o número ideal de árvores para utilização.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Criando Modelo de Regressao para calcular a velocidade média
predicao_velocidade_modelo = randomForest(velocidade_media ~ ., data = predicao_velocidade_treino, ntree=500, proximity=FALSE)
plot(predicao_velocidade_modelo, main = 'Regressao 500 Árvores - Velocidade Média')
O Modelo aparenta estabilizar a taxa de erro por volta das 160 árvores. Esse será o número utilizado para o aprendizado de máquina.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
# Criando Modelo de Regressao para calcular a velocidade média
predicao_velocidade_modelo = randomForest(velocidade_media ~ ., data = predicao_velocidade_treino, ntree=160, proximity=TRUE)
plot(predicao_velocidade_modelo, main = 'Regressao 160 Árvores - Velocidade Média')
Abaixo está um resumo de como o modelo ficou após a utilização de 160 árvores:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
predicao_velocidade_modelo
##
## Call:
## randomForest(formula = velocidade_media ~ ., data = predicao_velocidade_treino, ntree = 160, proximity = TRUE)
## Type of random forest: regression
## Number of trees: 160
## No. of variables tried at each split: 3
##
## Mean of squared residuals: 27.5432
## % Var explained: 75.92
Uma vez o modelo gerado podemos efetuar uma predição da velocidade média. Abaixo podemos ver uma pequena parcela de dados com o resultado após a predição.
# Predicao de velocidade media
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
predicao = predict(predicao_velocidade_modelo, predicao_velocidade_teste[,-11])
predicao_velocidade_teste$predicao = predicao
kable(head(select(predicao_velocidade_teste, velocidade_media, predicao), 20))
| velocidade_media | predicao | |
|---|---|---|
| 3 | 10.851433 | 13.000817 |
| 8 | 38.351131 | 35.492767 |
| 14 | 20.095436 | 18.652718 |
| 16 | 19.655505 | 18.009109 |
| 20 | 9.874470 | 10.284429 |
| 25 | 10.806302 | 12.573233 |
| 36 | 15.038074 | 16.011115 |
| 37 | 13.875401 | 14.716135 |
| 39 | 13.863081 | 13.481763 |
| 41 | 19.706642 | 29.567972 |
| 43 | 29.717371 | 25.541390 |
| 45 | 8.877771 | 12.735066 |
| 51 | 13.583930 | 14.023189 |
| 61 | 12.878947 | 13.255780 |
| 67 | 25.259943 | 22.309277 |
| 70 | 9.843680 | 12.272961 |
| 78 | 35.010443 | 28.524972 |
| 79 | 17.797836 | 16.624592 |
| 80 | 29.407123 | 28.000073 |
| 83 | 7.748006 | 8.288548 |
Aqui podemos consultar como está a distribuição de reziduos, que considera a subtração da velocidade média real com a velocidade média predita. Esses dados podem ser vistos no histograma abaixo:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
histograma = predicao_velocidade_teste$velocidade_media - predicao_velocidade_teste$predicao
xlabel = list(title = "Reziduo da Velocidade", titlefont = plotFonte)
ylabel = list(title = "Frequencia", titlefont = plotFonte)
plot_ly(x = histograma, type = 'histogram') %>%
layout(xaxis = xlabel, yaxis = ylabel)
O Root Mean Square (RMS) é uma métrica de cálculo que informa o erro esperado para cada predição realizada, para mais e para menos. Por exemplo:
Se o RMS for de 5km/h, significa que o dado da previsão, que foi 10km/h, pode ter uma variação 5km/h para mais, ou para menos. O Valor deste erro por ser visto abaixo, em uma grandeza de Km/h.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
rms(histograma)
## [1] 7.466229
Uma vez com a possibilidade de predizer a velocidade média, também é possível identificar o tempo estimado da viagem. O Modelo escolhido foi o RandomForest, e as variáveis serão:
# Modelo de Predicao de Tempo
segmentacao = rbind(segmentacao, data.frame("tipo" = "Programacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Modelagem", "valor" = 1))
predicao_tempo = data %>%
select(numero_mes_pickup, numero_dia_pickup, hora_pickup, minutos_pickup, manhattan,
velocidade_media, trip_duration) %>%
mutate(manhattan = normalizacao(manhattan),
numero_mes_pickup = normalizacao(numero_mes_pickup),
numero_dia_pickup = normalizacao(numero_dia_pickup),
hora_pickup = normalizacao(as.integer(hora_pickup)),
minutos_pickup = normalizacao(as.integer(minutos_pickup)),
velocidade_media = normalizacao(velocidade_media),
trip_duration = trip_duration)
A Separação do dataset se faz necessária para aprendizado do modelo matemático, que será feita em 2 partes: Conjunto de Treino e Conjunto de Teste.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Separando datasets
indice = sample(2, nrow(predicao_tempo), replace=TRUE, prob=c(0.7, 0.3))
# Treino
predicao_tempo_treino = predicao_tempo[indice==1,]
# Teste
predicao_tempo_teste = predicao_tempo[indice==2,]
Com nossos dados de entrada, vamos analisas as correlações entre as variávels:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Analise de Correlacoes
# Matriz com valores absolutos das correlacoes
matriz_modelagem_2 = abs(cor(predicao_tempo))
# Matriz diagonal recebe 0
diag(matriz_modelagem_2) = 0
# Retorna onde os indices sao TRUE, onde a matriz possui indice maior que 0.8
which(matriz_modelagem_2 > 0.8, arr.ind = T)
## row col
Nesse caso não existem correlações entre as variáveis.
O Modelo RandomForest será utilizado, porém, vamos analisar quantas árvores são necessárias para esse modelo. O Teste será feito com 500 árvores, e com o resultado no gráfico iremos decidir qual o número ideal de árvores para utilização.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Criando Modelo de Regressao para calcular a Tempo da Viagem
predicao_tempo_modelo = randomForest(trip_duration ~ ., data = predicao_tempo_treino, ntree=500, proximity=TRUE)
plot(predicao_tempo_modelo, main = 'Regressao 500 Árvores - Tempo da Viagem')
O Modelo aparenta estabilizar a taxa de erro por volta das 230 árvores. Esse será o número utilizado para o aprendizado de máquina.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Criando Modelo de Regressao para calcular Tempo da Viagem
predicao_tempo_modelo = randomForest(trip_duration ~ ., data = predicao_tempo_treino, ntree=230, proximity=TRUE)
plot(predicao_tempo_modelo, main = 'Regressao 230 Árvores - Tempo da Viagem')
Abaixo está um resumo de como o modelo ficou após a utilização de 230 árvores:
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
predicao_tempo_modelo
##
## Call:
## randomForest(formula = trip_duration ~ ., data = predicao_tempo_treino, ntree = 230, proximity = TRUE)
## Type of random forest: regression
## Number of trees: 230
## No. of variables tried at each split: 2
##
## Mean of squared residuals: 5445135
## % Var explained: 57.12
Uma vez o modelo gerado podemos efetuar uma predição da velocidade média. Abaixo podemos ver uma pequena parcela de dados com o resultado após a predição.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Machine Learning", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
# Predicao de duracao da corrida
predicao = predict(predicao_tempo_modelo, predicao_tempo_teste[,-11])
predicao_tempo_teste$predicao = round(predicao)
kable(head(select(predicao_tempo_teste, trip_duration, predicao), 20))
| trip_duration | predicao | |
|---|---|---|
| 3 | 2167 | 1920 |
| 4 | 601 | 597 |
| 7 | 1311 | 1180 |
| 9 | 259 | 313 |
| 10 | 879 | 908 |
| 16 | 291 | 347 |
| 21 | 183 | 284 |
| 24 | 1408 | 1371 |
| 25 | 537 | 535 |
| 26 | 279 | 351 |
| 28 | 268 | 323 |
| 32 | 166 | 225 |
| 34 | 1380 | 1210 |
| 35 | 224 | 257 |
| 36 | 1429 | 1359 |
| 38 | 456 | 483 |
| 42 | 396 | 458 |
| 43 | 143 | 247 |
| 45 | 253 | 339 |
| 47 | 483 | 537 |
Abaixo, temos um gráfico que informa a distribuição das informações de Duração preditas e reais.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Visualizacao", "valor" = 1))
histograma = predicao_tempo_teste$trip_duration - predicao_tempo_teste$predicao
xlabel = list(title = "Reziduo do Tempo, em s", titlefont = plotFonte)
ylabel = list(title = "Frequencia", titlefont = plotFonte)
plot_ly(x = histograma, type = 'histogram') %>%
layout(xaxis = xlabel, yaxis = ylabel)
O Root Mean Square (RMS) é uma métrica de cálculo que informa o erro esperado para cada predição realizada, para mais e para menos. Por exemplo:
Se o RMS for de 100s, significa que o dado da previsão, que foi 1100s, pode ter uma variação 100s para mais, ou para menos. O Valor deste erro por ser visto abaixo, em uma grandeza de segundos.
segmentacao = rbind(segmentacao, data.frame("tipo" = "Matematica", "valor" = 1))
rms(histograma)
## [1] 2901.001
Concluímos que com a utilização de Técnicas Estatisticas, Programação e Análise de Dados é possível identificar várias informações relevantes dentro de um dataset relativamente fraco. Com esses dados foi possível identificar os principais horários das corridas, as velocidades médias, onde as principais corridas ocorrem em função de determinados pontos de interesses, entre outras informações.
Com a análise podemos identificar as principais técnicas utilizadas ao decorrer do projeto, mostrando as principais tecnologias usadas para chegar até este ponto. Abaixo temos um gráfico que a quantidade de esforço separado por tipo de trabalho.
segmentacao_grafica = segmentacao %>%
group_by(tipo) %>%
summarise(total=n())
plot_ly(segmentacao_grafica, labels = segmentacao_grafica$tipo, values = segmentacao_grafica$total, type = 'pie') %>%
layout(title = 'Segmentação do Trabalho',
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))